home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CD ROM Paradise Collection 4
/
CD ROM Paradise Collection 4 1995 Nov.iso
/
games_d
/
hunchy.zip
/
GREDIT3.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1980-01-01
|
10KB
|
331 lines
program Graphics_Editor;
(*
GRAPHICS EDITOR FOR GETPIC & PUTPIC IN TURBO PASCAL 4.0
made especially for the graphics used by Hunch Back.
-----------------------------------------------------------
Up, Down, Left, Right, Home, End, PgUp, PgDn :
Cursor keys control the box cursor.
F1 - F4 : Choose color (Black,Cyan,Magenta,White).
F5 : Draw/Not draw in current color
F6 : Flip image horizontally
F7 : Flip image vertically
F8 : Clear image
F9 : Load image
F10 : Save image
INS : Center image
ESC : Quit (Answer Y or N)
*)
uses Crt, Graph3, Graph, CGAdrv;
type
St40 = string [40];
var
X,Y,Col,XCtr,YCtr,Tmp,Ex,Ey,Ex1,Ey1 : byte;
Crsr : array [1..10] of byte;
Icon : array [1..1675] of byte;
IconData : array [1..104,1..64] of byte;
Temp : array [1..3000] of byte;
Gd,Gm,Size,Ctr: integer;
Key : char;
Draw,Found:boolean;
FilName,OldF:st40;
Siz:string[10];
FilVar: file of byte;
function Exist (FilName:St40):boolean;
var fil:file; e:boolean;
begin
Assign (Fil,FilName); {$I-}
Reset (Fil); {$I+}
E:=(IOResult=0);
if E then Close (Fil);
Exist:=E;
end;
function ImSize(x1,y1,x2,y2:word):word;
var
x,y:word;
begin
x:=x2-x1+1; Y:=y2-y1+1;
ImSize:=(6+Trunc((x*2+7)/8)*y);
end;
procedure Cursor (X,Y:byte);
var X3,Y3:word;
begin
X3:=X*3; Y3:=Y*3;
SetColor(GetPixel(X3,Y3) xor 3);
Rectangle(X3-2,Y3-2,X3,Y3);
end;
procedure Frame (Col:byte);
begin
SetColor (Col);
Rectangle (0,0,313,193);
end;
procedure Dot (X,Y,Col:byte);
var
X3,Y3:integer;
begin
X3:=X*3; Y3:=Y*3;
SetColor(Col);
Rectangle(X3-2,Y3-2,X3,Y3);
PutPixel (X3-1,Y3-1,Col);
end;
procedure MakeWindow (x,y,x1,y1:integer);
begin
GetImage (x,y,x1,y1,Temp);
SetViewPort (x,y,x1,y1,ClipOn);
ClearViewPort;
SetColor (2);
Rectangle (0,0,x1-x,y1-y);
end;
procedure CloseWindow;
begin
PutImage (0,0,Temp,NormalPut);
SetViewPort (0,0,319,199,ClipOn);
end;
function Yes (Ask : St40):boolean;
var
Key:char;
begin
MakeWindow (104,78,216,102);
SetColor (3);
OutTextXY (56-(Length(Ask)*4),8,Ask);
Key:=ReadKey;
CloseWindow;
Yes:=(Key in ['Y','y']);
end;
procedure Clear;
begin
SetViewPort (1,1,312,192,True);
ClearViewPort;
SetViewPort (0,0,319,199,True);
for YCtr:=1 to 64 do
for XCtr:=1 to 104 do
IconData[XCtr,YCtr]:=0;
end;
procedure FindImage;
var
x,y:byte;
c:boolean;
procedure Fr(C:byte);
begin
SetColor(C);
Rectangle (Ex-1,Ey-1,Ex1+1,Ey1+1);
end;
begin
Found:=True;
Ex:=8; Ex1:=113; Ey:=8; Ey1:=73;
repeat
Inc(Ex);
y:=8; repeat Inc(y); c:=(GetPixel(Ex,y)>0);
until c or (y=73);
until c or (Ex=113);
if not c then begin
SetColor (3);
OutTextXY(24,36,'No Image!');
Found:=False;
end else begin
repeat
Dec(Ey1);
x:=Ex-1; repeat Inc(x); c:=(GetPixel(x,Ey1)>0);
until c or (x=Ex1);
until c or (Ey1=8);
repeat
Dec(Ex1);
y:=8; repeat Inc(y); c:=(GetPixel(Ex1,y)>0);
until c or (y=Ey1);
until c or (Ex1=8);
repeat
Inc(Ey);
x:=Ex-1; repeat Inc(x); c:=(GetPixel(x,Ey)>0);
until c or (x=Ex1);
until c or (Ey=Ey1);
GetPic (Icon,100+Ex,50+Ey,100+Ex1,50+Ey1);
(* SetColor (1); SetLineStyle (DottedLn,0,1);
Fr(3);
SetLineStyle (SolidLn,0,1);*)
Size:=ImSize (Ex,Ey,Ex1,Ey1);
Str(Size,Siz);
SetColor (3);
OutTextXY (20,78,'Size: '+Siz);
end;
end;
procedure MakeIconData(x,y:byte);
begin
MakeWindow (100,50,220,138);
PutPic (Icon,108+x,122-y);
for XCtr:=1 to 104 do
for YCtr:=1 to 64 do
IconData[XCtr,YCtr]:=GetPixel (8+XCtr,8+YCtr);
CloseWindow;
for XCtr:=1 to 104 do
for YCtr:=1 to 64 do
if IconData[XCtr,YCtr]>0 then Dot(XCtr,YCtr,IconData[XCtr,YCtr]);
end;
procedure ShowImage;
var Key:char;
begin
MakeWindow (100,50,220,138);
for XCtr:=1 to 104 do
for YCtr:=1 to 64 do
PutPixel (8+XCtr,8+YCtr,IconData [XCtr,YCtr]);
FindImage;
Key:=ReadKey;
CloseWindow;
end;
function GetFileName (OldF:St40; Txt:St40):St40;
var
FilName:St40;
begin
MakeWindow(104,72,216,107);
SetColor (3); OutTextXY (8,7,Txt+' file:');
Window (15,12,26,13); OutTextXY(8,16,OldF);
repeat until KeyPressed;
repeat ClrScr; GotoXY(1,1); Readln (FilName);
until ((FilName='') and (OldF>'')) or (FilName>'');
Window (1,1,40,25); CloseWindow;
if FilName>'' then GetFileName:=FilName
else GetFileName:=OldF;
end;
begin
RegisterCGA;
InitCGA (CGAC3);
GraphColorMode;
FillChar(IconData,SizeOf(IconData),0);
FilName:='';
X:=52; Y:=32; Draw:=False; Col:=3;
Frame (Col);
Cursor (X,Y);
repeat
Key:=ReadKey;
Cursor (X,Y);
if Draw then begin
IconData [X,Y]:=Col;
Dot (X,Y,Col);
end;
case Key of
#0 : begin
if KeyPressed then begin
Key:=ReadKey;
case Key of
'G': begin Dec (Y); Dec (X); end;
'H': Dec (Y);
'I': begin Dec (Y); Inc (X); end;
'K': Dec (X);
'M': Inc (X);
'O': begin Inc (Y); Dec (X); end;
'P': Inc (Y);
'Q': begin Inc (Y); Inc (X); end;
#59..#62: begin
Col:=Ord(Key)-59;
Dot (X,Y,Col);
IconData [X,Y]:=Col;
Frame (Col);
end;
#63: Draw:=not Draw;
#64: begin
for YCtr:=1 to 32 do
for XCtr:= 1 to 104 do
if IconData[XCtr,YCtr]<>IconData[XCtr,65-YCtr] then begin
Tmp:=IconData [XCtr,YCtr];
IconData[XCtr,YCtr]:=IconData[XCtr,65-YCtr];
IconData[XCtr,65-YCtr]:=Tmp;
Dot (XCtr,YCtr,IconData [XCtr,YCtr]);
Dot (XCtr,65-YCtr,Tmp);
end;
Y:=65-Y;
end;
#65: begin
for XCtr:=1 to 52 do
for YCtr:= 1 to 64 do
if IconData[XCtr,YCtr]<>IconData[105-XCtr,YCtr] then begin
Tmp:=IconData [XCtr,YCtr];
IconData[XCtr,YCtr]:=IconData[105-XCtr,YCtr];
IconData[105-XCtr,YCtr]:=Tmp;
Dot (XCtr,YCtr,IconData [XCtr,YCtr]);
Dot (105-XCtr,YCtr,Tmp);
end;
X:=105-X;
end;
#66: if Yes ('Clear Image?') then Clear;
#67: begin
if Yes('Load Image?') then begin
FilName:=GetFileName(FilName,'Load');
if Exist(FilName) then begin
Assign (FilVar,FilName);
Reset (FilVar);
for Ctr:=1 to 6 do
Read (FilVar,Icon[Ctr]);
Size:=ImSize(1,1,Icon[4]*256+Icon[3],
Icon[6]*256+Icon[5]);
for Ctr:=7 to Size do
Read (FilVar,Icon[Ctr]);
Close (FilVar);
Clear;
MakeIconData(52-(Icon[4]*256+Icon[3]) div 2,
31-(Icon[6]*256+Icon[5]) div 2);
(* CloseGraph;
for Ctr:=1 to Size do Write(Icon[Ctr]:4);
Key:=ReadKey;
InitCGA(CGAC1);*)
end else Write (Chr(7));
end;
end;
#68: begin
ShowImage;
if Found then if Yes('Save Image?') then begin
Size:=ImSize(Ex,Ey,Ex1,Ey1);
(* CloseGraph;
for Ctr:=1 to Size do Write(Icon[Ctr]:4);
Key:=ReadKey;
InitCGA(CGAC1);*)
FilName:=GetFileName(FilName,'Save');
Found:=Exist(FilName);
if Found then Found:=not Yes('Overwrite?');
if not Found then begin
Assign (FilVar,FilName);
ReWrite (FilVar);
for Ctr:=1 to Size do
Write (FilVar,Icon[Ctr]);
Close (FilVar);
end;
end;
end;
#82: begin
ShowImage;
if Found then if Yes ('Center Img.?') then begin
Clear;
MakeIconData(52-(Ex1-Ex) div 2,31-(Ey1-Ey) div 2);
end;
end;
end;
if X>104 then X:=1;
if X<1 then X:=104;
if Y<1 then Y:=64;
if Y>64 then Y:=1;
end;
end;
end;
Cursor (X,Y);
if Key=#27 then
if Yes ('Quit GREDIT?')=False then Key:=#0;
until Key=#27;
TextMode (CO80);
end.